home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / svgadc30.zip / svga.pas < prev    next >
Pascal/Delphi Source File  |  1993-03-03  |  42KB  |  1,603 lines
  1. Unit SVGA;
  2.  
  3. INTERFACE
  4.  
  5. const
  6.    ButtonL = 0; ButtonR = 1; ButtonM = 2;
  7.    OFF      = 0;  ON       = 1;
  8.  
  9. Type
  10.   RGB = record
  11.         Red, Grn, Blu : byte
  12.         end;
  13.   PaletteRegister = array[0..255] of RGB;
  14.   SetTypes = ( FutureFont, StandardFont );
  15.   ResType = ( VGA, SVGA6440, SVGA6448, SVGA8060, SVGA1076 );
  16.   Position = record
  17.                BtnStatus,
  18.                opCount,
  19.                XPos, YPos : integer;
  20.              end;
  21.   EventRec = record
  22.                Event,
  23.                BtnStatus,
  24.                XPos, YPos : word;
  25.              end;
  26.   YPtr = ^YType;
  27.   YType = record
  28.             Col1, Col2, Col3, Col4 : byte; { Due to TP's memory }
  29.             NextY : YPtr;                  { memory management }
  30.           end;                             { pointers are multiples}
  31.    XPtr = ^XType;                           { of 8 bytes }
  32.    XType = record
  33.              NextX : XPtr;
  34.              Y : YPtr;
  35.            end;
  36.  
  37.   GenMouse = object
  38.       procedure SetAccel( threshold : integer );
  39.         { Set Acceleration of mouse }
  40.       procedure Getposition( var BtnStatus, XPos, YPos : integer );
  41.         { Gets the Position of the mouse and returns button status }
  42.       procedure QueryBtnDn( button : integer; var mouse : Position );
  43.         { Checks if queried button was pressed }
  44.       procedure QueryBtnUp( button : integer; var mouse : Position );
  45.         { Checks if queried button is released }
  46.       procedure ReadMove( var XMove, YMove : integer );
  47.         { Reports absolute mouse movement since last call to ReadMove }
  48.       procedure Reset( var Status : boolean; var BtnCount : integer );
  49.         { Resets the mouse to default conditions }
  50.       procedure SetRatio( horPix, verPix : integer );
  51.         { Sets speed of mouse }
  52.       procedure SetLimits( XPosMin, YPosMin, XPosMax, YPosMax : integer );
  53.         { Creates View Port for which mouse can operate in }
  54.       procedure SetPosition( XPos, YPos : integer );
  55.         { Puts mouse to desired point on screen }
  56.    end;
  57.  
  58.   GraphicMouse = object( GenMouse )
  59.     procedure Initialize;
  60.       { Sets default conditons for graphics mouse }
  61.     procedure Show( ShowM : boolean );
  62.       { Either shows or hides the graphics mouse }
  63.     procedure MPlot( xx, yy : integer );
  64.     procedure CheckMouse;
  65.       { Checks if mouse has been moved since last call and moves mouse accordingly }
  66.     procedure ExitSVGA;
  67.       { Exits Graphics mouse and resets it back to text mode }
  68.   end;
  69.  
  70. procedure SetMode( Mode : Restype );
  71.   { Sets Graphics card to desired mode }
  72. function WhichBank( x, y : integer ): byte;
  73.  
  74. procedure LoadWriteBank( Segment : byte );
  75.   { Loads particular bank for read/write operations }
  76. procedure Plot( x, y : integer; Color : byte );
  77.   { Plots a point to screen }
  78. procedure PutImage( x, y : integer; Img : XPtr );
  79.   { Puts an image in memory to screen at point (x,y), top left hand corner }
  80. procedure LoadImage( ImageName : string; var ImagePtr : XPtr );
  81.   { Loads image from disk and puts into memory }
  82. procedure DisposeImage( var Img : XPtr );
  83.   { Deletes image from memory }
  84. procedure SetColor( PalNum: byte; Hue : RGB );
  85.   { Sets Color of a particular pallette }
  86. function  GetPixel( x, y : integer ) : byte;
  87.   { Returns color of a pixel }
  88. procedure SetPalette( Hue : PaletteRegister );
  89.   { Sets all 256 pallette registers to desired pallette }
  90. procedure CyclePalette;
  91.   { Rotates all colors in the pallette in repetitive cycle }
  92. procedure Circle( x, y, Radius : word; Color : byte );
  93.   { Draws a circle }
  94. procedure Line( xx1, yy1, xx2, yy2 : integer; Color : byte );
  95.   { Draws a line }
  96. procedure ClearDevice;
  97.  
  98. procedure ClearPort( x1, y1, x2, y2 : integer );
  99.   { Clears a Section of the screen }
  100. procedure Rectangle( x1, y1, x2, y2 : word; Color : byte );
  101.   { Draws a rectangle outline i.e not solid }
  102. procedure RectFill( x1, y1, x2, y2 : integer; Color : byte );
  103.   { Draws a solid Rectangle }
  104. procedure ExitGraphics;
  105.   { Exits SVGA Graphics and returns to normal text mode }
  106. procedure OutTextXY( x, y : integer; word : string );
  107.   { Writes text to screen at point X, Y }
  108. procedure LoadFont( CharSetName: SetTypes );
  109.   { Loads a particular Font for use }
  110. procedure SetFont( Font : SetTypes );
  111.   { If two or more fonts are in memory this allows you to choose one }
  112. procedure SetFontColor( Color, BackCol : byte; Trans : boolean );
  113.   { Set forground & background color of text & transparent background or not }
  114.   { i.e write background to screen or skip it and only write letter          }
  115. procedure LoadPalette( PaletteName : string );
  116.   { Loads a particular pallette from disk }
  117.  
  118. var  Color : PaletteRegister;
  119.      Bytes_per_Line, GetMaxX, GetMaxY : integer;
  120.      mEvent : EventRec;
  121.      PresentSeg : byte;
  122.  
  123. IMPLEMENTATION
  124.  
  125. Uses Dos, Crt;
  126.  
  127. type  FCharType = array[ 0..15, 0..12 ] of boolean;
  128.       FCharSetType = array[ 0..95 ] of FCharType;
  129.       SCharType = array[ 0..7, 0..9 ] of boolean;
  130.       SCharSetType = array[ 0..95 ] of SCharType;
  131.       CardType = ( AheadA, AheadB, ATI, ChipsTech, Everex, Genoa,
  132.                   Paradise, Trident, Tseng3000, Tseng4000, Video7 );
  133.       NameType = string[30];
  134.  
  135. var
  136.   Mxx, Mxy, Mnx, Mny, XRes, YRes, X, Y, OldX, OldY : integer;
  137.   regs : registers;
  138.   Future : ^FCharSetType;
  139.   Standard : ^SCharSetType;
  140.   Width, Height, FontColor, BackGroundColor : byte;
  141.   PresentSet : SetTypes;
  142.   ShowMouse, Transparent, Sused, Fused : boolean;
  143.   Card : CardType;
  144.   MP, ColOld : array[ 0..3, 0..3 ] of byte;
  145.  
  146.  
  147. function Ahead : NameType;
  148.  
  149.   begin
  150.     Portw[$3CE] := $200F;
  151.     if Port[$3CF] = $20 then Ahead := 'Ahead A'
  152.       else if Port[$3CF] = $21 then Ahead := 'Ahead B'
  153.         else Ahead := 'False';
  154.   end;
  155.  
  156. function AnATI : NameType;
  157.  
  158.   var s : NameType;
  159.       Temp : string;
  160.  
  161.   begin
  162.     s[0] := #9;
  163.     move(mem[$C000:$31],s[1],9);
  164.     if s = '761295520'then
  165.       begin
  166.         Temp := 'ATI';
  167.         if memw[$C000:$40] = $3331 then
  168.           begin
  169.             Temp := Temp + ' Super VGA';
  170.             Regs.AH := $12;
  171.             Regs.BX := $5506;
  172.             Regs.AL := $55;
  173.             Regs.BP := $FFFF;
  174.             Regs.SI := $0;
  175.             intr( $10, Regs );
  176.             if Regs.BP = $FFFF then Temp := Temp + ' Revision 1'
  177.               else Temp := Temp + ' Revision 2/3';
  178.           end
  179.         else
  180.           Temp := 'False';
  181.         AnATI := Temp;
  182.       end
  183.     else AnATI := 'False';
  184.   end;
  185.  
  186. function AChipsTech : Nametype;
  187.  
  188.   var OldValue, Value : byte;
  189.       Temp : string;
  190.  
  191.   begin
  192.     Port[$3C3] := Port[$3C3] or 16;
  193.     if Port[$104] = $A5 then
  194.       begin
  195.         Temp:= 'Chips & Technologies';
  196.         Port[$3C3] := Port[$3C3] and $EF;
  197.         Port[$3D6] := 0;
  198.         case Port[$3D7] shr 4 of
  199.           2 : Temp := Temp + ' 82c455';
  200.           3 : Temp := Temp + ' 82c453';
  201.           5 : Temp := Temp + ' 82c456';
  202.           1 : begin
  203.                 Port[$3D6] := $3A;
  204.                 OldValue := Port[$3D7];
  205.                 Port[$3D7] := $AA;
  206.                 Value := Port[$3D7];
  207.                 Port[$3D7] := OldValue;
  208.                 if Value = $AA then Temp := Temp + ' 82c452'
  209.                   else Temp := Temp + ' 82c451';
  210.               end;
  211.           end;
  212.         AChipsTech := Temp;
  213.       end
  214.     else AChipsTech := 'False';
  215.   end;
  216.  
  217. function AnEverex : NameType;
  218.  
  219.   var Value : byte;
  220.       s : NameType;
  221.  
  222.   begin
  223.     Regs.AX := $7000;
  224.     Regs.BX := 0;
  225.     intr( $10, Regs );
  226.     if Regs.AL = $70 then
  227.       begin
  228.         Value := Regs.DX shr 4;
  229.         if Value = $678 then AnEverex := 'Everex Ev678'
  230.           else if Value = $236 then AnEverex := 'Everex Ev236'
  231.             else begin
  232.                    str( Value, s );
  233.                    AnEverex := 'Everex Ev'+ s;
  234.                  end;
  235.       end
  236.     else AnEverex := 'False';
  237.   end;
  238.  
  239. function AGenoa : Nametype;
  240.  
  241.   begin
  242.     if (meml[$C000:mem[$C000:$37]] and $FFFF00FF) = $66990077 then
  243.       begin
  244.         case mem[$C000:mem[$C000:$37] + 1] of
  245.           $33, $55 : AGenoa := 'Tseng ET3000';
  246.                $22 : AGenoa := 'Genoa 610